home *** CD-ROM | disk | FTP | other *** search
/ The Best of MacTutor - S…e Code for Volumes 1 to 5 / The Best of MacTutor - Source Code for Volume 1-5 (Wayzata Technology)(6031)(1990).bin / Source Code / #49 (Oct 89) / Lazy-Lists.Lisp next >
Lisp/Scheme  |  1989-05-10  |  6KB  |  154 lines
  1. ;;;This file contains all kinds of wonderful "stream" stuff from Abelson and
  2. ;;;Sussman.  The problem is that "stream" means something else within the
  3. ;;;context of Common Lisp and therefore within Pearl Lisp, so I call 'em
  4. ;;;"lazy-lists," which to me makes more sense anyway.
  5.  
  6. ;;Define the empty lazy list:
  7. (defconstant the-empty-lazy-list '())
  8.  
  9. ;;How do we know if a lazy-list is empty?
  10. (defun empty-lazy-list-p (lazy-list)
  11.   (eq the-empty-lazy-list lazy-list))
  12.  
  13. ;;This function optimizes DELAY so that the function created is only called once.
  14. (defun memoize (fun)
  15.   (let ((already-evaled nil) (value nil))
  16.     #'(lambda ()
  17.         (if already-evaled
  18.           value
  19.           (prog1
  20.             (setf value (funcall fun))
  21.             (setf already-evaled t))))))
  22.  
  23. ;;Here is the DELAY macro:
  24. (defmacro delay (thing)
  25.   `(memoize #'(lambda () ,thing)))
  26.  
  27. ;;Here is the FORCE function:
  28. (defun force (promise)
  29.   (funcall promise))
  30.  
  31. ;;Here is our lazy-list CONStructor:
  32. (defmacro lazy-cons (thing lazy-list)
  33.   `(cons ,thing (delay ,lazy-list)))
  34.  
  35. ;;Here are LAZY-CAR and LAZY-CDR:
  36. (defun lazy-car (lazy-list)
  37.   (car lazy-list))
  38.  
  39. (defun lazy-cdr (lazy-list)
  40.   (force (cdr lazy-list)))
  41.  
  42. ;;This is to lazy lists what Common Lisp's APPEND is to normal lists.
  43. (defun append-lazy-lists (l1 l2)
  44.   (if (empty-lazy-list-p l1)
  45.     l2
  46.     (lazy-cons (lazy-car l1)
  47.                (append-lazy-lists (lazy-cdr l1) l2))))
  48.  
  49. ;;This is a nice, generic accumulation function that takes a combiner function
  50. ;;(usually #'+ or #'cons or something like that), an initial value (typically
  51. ;;0 or 1 for numeric accumulations or '() for lists) and some lazy-list to
  52. ;;apply all of this to.
  53. (defun accumulate (combiner initial-value lazy-list)
  54.   (if (empty-lazy-list-p lazy-list)
  55.     initial-value
  56.     (funcall combiner (lazy-car lazy-list)
  57.              (delay (accumulate combiner
  58.                          initial-value
  59.                          (lazy-cdr lazy-list))))))
  60.  
  61. ;;This function prevents infinite recursion when accumulating infinite lazy-lists.
  62. (defun interleave (l1 l2)
  63.   (if (empty-lazy-list-p l1)
  64.     (force l2)
  65.     (lazy-cons (lazy-car l1)
  66.                (interleave (force l2) (delay (lazy-cdr l1))))))
  67.  
  68. ;;This handy thing uses ACCUMULATE to flatten a lazy-list of lazy-lists.
  69. (defun flatten (lazy-list)
  70.   (accumulate #'interleave the-empty-lazy-list lazy-list))
  71.  
  72. ;;This maps some proc across every element of some lazy-list.
  73. (defun lazy-map (proc lazy-list)
  74.   (if (empty-lazy-list-p lazy-list)
  75.     the-empty-lazy-list
  76.     (lazy-cons (funcall proc (lazy-car lazy-list))
  77.                (lazy-map proc (lazy-cdr lazy-list)))))
  78.  
  79. ;;This returns the lazy-list that contains all items that, when passed to pred,
  80. ;;return something non-NIL.
  81. (defun filter (pred lazy-list)
  82.   (cond ((empty-lazy-list-p lazy-list) the-empty-lazy-list)
  83.         ((funcall pred (lazy-car lazy-list))
  84.          (lazy-cons (lazy-car lazy-list)
  85.                     (filter pred (lazy-cdr lazy-list))))
  86.         (t (filter pred (lazy-cdr lazy-list)))))
  87.  
  88. ;;This is an awful lot like LAZY-MAP, except that it doesn't accumulate its
  89. ;;results, which is a fancy way of saying that you use LAZY-MAP if you need
  90. ;;a function result and FOR-EACH if you need side-effects.
  91. (defun for-each (proc lazy-list)
  92.   (if (empty-lazy-list-p lazy-list)
  93.     'done
  94.     (progn (funcall proc (lazy-car lazy-list))
  95.            (for-each proc (lazy-cdr lazy-list)))))
  96.  
  97. ;;Flattening the result of lazy-mapping is so useful and so common that there's
  98. ;;a whole separate function for it.
  99. (defun flatmap (f s)
  100.   (flatten (lazy-map f s)))
  101.  
  102. ;;Sometimes (ok, rarely) it's nice to convert a list to a lazy-list:
  103. (defun lazy-list (list)
  104.   (if (null list)
  105.     the-empty-lazy-list
  106.     (lazy-cons (car list) (lazy-list (cdr list)))))
  107.  
  108. ;;This is the tricky one.  The COLLECT macro makes nested mappings a tad easier
  109. ;;than they would be otherwise, but this is the most complex macro I've ever
  110. ;;had to write.  Here goes nothing:
  111. (defmacro collect (result pairs &optional (restriction t))
  112.   (let ((vars (mapcar #'car pairs))
  113.         (sets (mapcar #'cadr pairs))
  114.         (lets (genlets pairs)))
  115.     `(lazy-map #'(lambda (tuple)
  116.                    (let ,lets
  117.                      ,result))
  118.                (filter #'(lambda (tuple)
  119.                            (let ,lets
  120.                              ,restriction))
  121.                        ,(genmaps vars sets)))))
  122.  
  123. ;;Given a list of pairs, this creates a let body based on tuple.
  124. (defun genlets (pairs)
  125.   (do ((i (1- (length pairs)) (1- i))
  126.        (result '() (cons (cons (car (nth i pairs)) (list (list 'nth i 'tuple))) result)))
  127.       ((< i 0) result)))
  128.  
  129. ;;This beast generates the flatmap/lazy-map sequence for the vars and sets.
  130. (defun genmaps (vars sets)
  131.   (labels ((genmaps-1 (vars sets depth)
  132.                       (if (null (cdr sets))
  133.                         `(lazy-map #'(lambda (,(car (last vars)))
  134.                                          (list ,@vars))
  135.                                      ,(car sets))
  136.                         `(flatmap #'(lambda (,(nth depth vars))
  137.                                       ,(genmaps-1 vars (cdr sets) (1+ depth)))
  138.                                   ,(car sets)))))
  139.     (genmaps-1 vars sets 0)))
  140.  
  141. (defconstant ones (lazy-cons 1 ones))
  142.  
  143. (defun add-lazy-lists (l1 l2)
  144.   (cond ((empty-lazy-list-p l1) l2)
  145.         ((empty-lazy-list-p l2) l1)
  146.         (t
  147.          (lazy-cons (+ (lazy-car l1) (lazy-car l2))
  148.                     (add-lazy-lists (lazy-cdr l1) (lazy-cdr l2))))))
  149.  
  150. (defconstant integers (lazy-cons 1 (add-lazy-lists ones integers)))
  151.  
  152. (defun scale-lazy-list (c lazy-list)
  153.   (lazy-map #'(lambda (x) (* x c)) lazy-list))
  154.